home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / f83 / multitask < prev    next >
Encoding:
Text File  |  1992-04-20  |  11.6 KB  |  326 lines
  1. \
  2. \  MULTI-TASKING DEFINITIONS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 4 September 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, enumerates, structures, blocks, queues
  20. \
  21. \  Description:
  22. \       Allows definition of tasks, condition queues, semaphores, channels,
  23. \       and rendezvous. Follows the basic models of concurrent programming
  24. \       primitives. 
  25. \
  26. \  Copying:
  27. \       This program is free software; you can redistribute it and\or modify
  28. \       it under the terms of the GNU General Public License as published by
  29. \       the Free Software Foundation; either version 1, or (at your option)
  30. \       any later version.
  31. \
  32. \       This program is distributed in the hope that it will be useful,
  33. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  34. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35. \       GNU General Public License for more details.
  36. \
  37. \       You should have received a copy of the GNU General Public License
  38. \       along with this program; see the file COPYING.  If not, write to
  39. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  40.  
  41. .( Loading Multi-tasking definitions...) cr
  42.  
  43. #include <Tile$Lib>.enumerates
  44. #include <Tile$Lib>.structures
  45. #include <Tile$Lib>.blocks
  46. #include <Tile$Lib>.queues
  47.  
  48. blocks queues structures multi-tasking definitions
  49.  
  50. ( Task structure and status codes)
  51.  
  52. struct.type TASK-HEADER ( -- )
  53.   struct QUEUE +queue ( task -- addr) private
  54.   enum +status ( task -- addr) private
  55.   ptr  +sp ( task -- addr) private
  56.   ptr  +s0 ( task -- addr) private
  57.   ptr  +ip ( task -- addr) private
  58.   ptr  +rp ( task -- addr) private
  59.   ptr  +r0 ( task -- addr) private
  60.   ptr  +fp ( task -- addr) private
  61.   ptr  +ep ( task -- addr) private
  62.   ptr  +display ( task -- addr) private
  63. struct.end
  64.  
  65. enumerates
  66.  
  67. enum.type TASK-STATUS-CODES ( -- )
  68.   enum TERMINATED ( -- enum)           ( Terminated status code)
  69.   enum READY ( -- enum)                        ( Ready for "schedule")
  70.   enum RUNNING ( -- enum)              ( Scheduled and running)
  71.   enum IOWAITING ( -- enum)            ( Waiting for in- or output)
  72.   enum WAITING ( -- enum)              ( Generic waiting)
  73.   enum DELAYED ( -- enum)              ( In delay function call)
  74. enum.end
  75.   
  76. multi-tasking
  77.  
  78. ( Task inquiry and manipulation functions)
  79.  
  80. : .task ( task -- )
  81.   dup foreground @ =                   ( Check for foreground task)
  82.   if ." foreground#" else ." task#" then
  83.   dup . cr                             ( Print task fields)
  84.   ." queue: " dup +queue .queue cr     ( The task queue pointers)
  85.   ." status: "dup +status @ . cr       ( The task status field)
  86.   ." sp: " dup +sp @ . cr              ( The task stack pointer)
  87.   ." s0: " dup +s0 @ . cr              ( The task stack bottom pointer)
  88.   ." ip: " dup +ip @ . cr              ( The task instruction pointer)
  89.   ." rp: " dup +rp @ . cr              ( The task return stack pointer)
  90.   ." r0: " dup +r0 @ . cr              ( The task return stack bottom pointer)
  91.   ." fp: " dup +fp @ . cr              ( The task argument frame pointer)
  92.   ." ep: " dup +ep @ . cr              ( The task exception frame pointer)
  93.   ." display: " +display @ . cr        ( The task display handle)
  94. ;
  95.  
  96. : deactivate ( queue task -- ) 
  97.   WAITING over +status !               ( Mark as waiting)
  98.   running @ succ >r                    ( Access the next runnable task)
  99.   dup dequeue                          ( Remove this task from the queue)
  100.   swap enqueue                         ( And insert into queue of waiting)
  101.   r> resume                            ( The next task)
  102. ;                                      
  103.  
  104. : activate ( task -- ) 
  105.   RUNNING over +status !               ( Restore running state)
  106.   running @ succ enqueue               ( And insert it after the current task)
  107.   detach                               ( And restart it)
  108. ;
  109.  
  110. : delay ( n -- )
  111.   DELAYED running @ +status !          ( Indicate that the task is delayed)
  112.   0 do detach loop                     ( Delay a task a number of switches)
  113.   RUNNING running @ +status !          ( Restore running state)
  114. ;
  115.  
  116. : join ( task -- ) 
  117.   WAITING running @ +status !          ( Indicate that the task is waiting)
  118.   begin                                        ( Wait for task to terminate)
  119.     dup +status @                      ( Check status. While not zero)
  120.   while                                        ( and thus not terminate)
  121.     detach                             ( Switch tasks)
  122.   repeat drop                          ( Drop task parameter)
  123.   RUNNING running @ +status !          ( Restore running state)
  124. ;
  125.  
  126. : who ( -- ) 
  127.   ." task#: " running @                        ( Print header and list of tasks)
  128.   block[ ( task -- ) . ]; map-queue
  129. ;
  130.  
  131. ( Condition Queue Variables)
  132.  
  133. struct.type CONDITION ( -- )
  134.   struct QUEUE +waiting ( condition -- addr) private
  135. struct.init ( condition -- )
  136.   +waiting as QUEUE initiate           ( Initiate condition queue)
  137. struct.end
  138.  
  139. : await ( condition -- )
  140.   +waiting running @ deactivate        ( Deactivate the current task)
  141. ;
  142.  
  143. : cause ( condition -- )
  144.   +waiting dup ?empty-queue            ( Check for empty queue)
  145.   if drop                              ( Drop and return)
  146.   else                                 ( Else activate the first waiting)
  147.     +waiting succ dup dequeue activate ( task in the condition queue)
  148.   then
  149. ;
  150.  
  151. ( Dijkstra's Semaphore definition)
  152.  
  153. struct.type SEMAPHORE ( n -- )
  154.   struct CONDITION +not.zero ( semaphore -- addr) private
  155.   long +count ( semaphore -- addr) private
  156. struct.init ( n semaphore -- )
  157.   dup +not.zero as CONDITION initiate  ( Initiate semaphore condition)
  158.   +count !                             ( Initiate semaphore counter)
  159. struct.end
  160.  
  161. : mutex ( -- )
  162.   1 SEMAPHORE                          ( Mutual exclusion semaphore)
  163. ;
  164.  
  165. : signal ( semaphore -- ) 
  166.   dup +not.zero +waiting ?empty-queue  ( Check if the waiting queue is empty)
  167.   if 1 swap +count +!                  ( Increment counter)
  168.   else
  169.     +not.zero cause                    ( Cause not zero condition)
  170.   then
  171. ;
  172.  
  173. : ?wait ( semaphore -- bool) 
  174.   +count @ 0=                          ( Check if a wait will delay the task)
  175. ;
  176.  
  177. : wait ( semaphore -- ) 
  178.   dup ?wait                            ( Does the task have to wait)
  179.   if +not.zero await                   ( Await not zero counter)
  180.   else
  181.     -1 swap +count +!                  ( Decrement the counter)
  182.   then
  183. ;
  184.  
  185. ( Extension of Hoare's Channels)
  186.  
  187. enum.type COMMUNICATION-MODES ( -- )
  188.   enum ONE-TO-ONE ( -- enum)           ( Task to task communication)
  189.   enum ONE-TO-MANY ( -- enum)          ( One task to several tasks)
  190.   enum MANY-TO-ONE ( -- enum)          ( Several task to one task)
  191. enum.end
  192.  
  193. struct.type CHAN ( mode -- )
  194.   long +data ( chan -- addr) private
  195.   long +mode ( chan -- addr) private
  196.   struct SEMAPHORE +sent ( chan -- addr) private
  197.   struct SEMAPHORE +received ( chan -- addr) private
  198. struct.init ( mode chan -- )
  199.   tuck +mode !                         ( Set up channel mode)
  200.   0 over +sent as SEMAPHORE initiate   ( Initiate semaphore fields)
  201.   0 swap +received as SEMAPHORE initiate ( as synchronize semaphores)
  202. struct.end
  203.  
  204. : ?avail ( chan -- bool) 
  205.   dup +mode @ MANY-TO-ONE =            ( Check channel mode)
  206.   if +received ?wait not               ( Check if receiver is available)
  207.   else +sent ?wait not then            ( Check if sender is available)
  208. ;
  209.  
  210. : send ( data chan -- ) 
  211.   dup +mode @ MANY-TO-ONE =            ( Check mode first)
  212.   if dup +received wait                        ( Wait for a receiver)
  213.     tuck +data !                       ( Assign data field)
  214.     +sent signal                       ( And signal the receiver)
  215.   else
  216.     tuck +data !                       ( Assign data field of channel)
  217.     dup +sent signal                   ( Signal that data is available)
  218.     +received wait                     ( And wait for receiver to fetch)
  219.   then
  220. ;
  221.  
  222. : receive ( chan -- data)  
  223.   dup +mode @ MANY-TO-ONE =            ( Check mode first)
  224.   if dup +received signal              ( Signal a receiver is ready)
  225.     dup +sent wait                     ( Wait for sender)
  226.     +data @                            ( Fetch sent data from channel)
  227.   else
  228.     dup +sent wait                     ( Wait for sender to send data)
  229.     dup +data @                        ( Fetch data from channel)
  230.     swap +received signal              ( And acknowledge to sender)
  231.   then
  232. ;
  233.      
  234. ( Message passing; rendezvous)
  235.  
  236. struct.type RENDEZVOUS ( -- )
  237.   struct CHAN +arg ( rendezvous -- addr) private
  238.   struct CHAN +res ( rendezvous -- addr) private
  239. struct.init ( rendezvous -- )
  240.   ONE-TO-ONE over +arg as CHAN initiate        ( Initiate argument channel)
  241.   ONE-TO-ONE swap +res as CHAN initiate        ( Initiate result channel)
  242. struct.does ( arg rendezvous -- res)
  243.   tuck +arg send                       ( Send the argument)
  244.   +res receive                         ( and receive the result)
  245. struct.end
  246.  
  247. : accept ( -- rendezvous arg)
  248.   ' >body [compile] literal            ( Access the rendezvous structure)
  249.   ?compile dup                         ( Receive the argument to this task)
  250.   ?compile receive
  251. ; immediate
  252.  
  253. : accept.end ( rendezvous res -- )
  254.   ?compile swap                                ( Send the result to the sender)
  255.   ?compile +res
  256.   ?compile send
  257. ; immediate
  258.  
  259. : ?awaiting ( -- bool)
  260.   ' >body [compile] literal            ( Access the rendezvous structure)
  261.   ?compile ?avail
  262. ; immediate
  263.  
  264. ( High Level Task definition with user variables)
  265.  
  266. forward make-task ( task.type -- task)
  267.  
  268. struct.type task.type ( parameters returns -- )
  269.   long +users ( task.type -- addr) private
  270.   long +parameters ( task.type -- addr) private
  271.   long +returns ( task.type -- addr) private
  272.   ptr  +body ( task.type -- addr) private
  273. struct.init ( parameters returns task.type -- entry task.type users0)
  274.   dup >r +returns !                    ( Assign given fields)
  275.   r@ +parameters !                     ( And prepare for definition of)
  276.   last r> sizeof TASK-HEADER           ( user variable fields for tasks)
  277. struct.does ( task -- )
  278.   make-task dup schedule constant      ( Make a task, start it)
  279. struct.end                             ( And give it a name)
  280.  
  281. : make-task ( task.type -- task)
  282.   dup >r +users @                      ( Fetch task size parameters)
  283.   r@ +parameters @                     ( And pointer to task body)
  284.   r@ +returns @                        ( And create a task instance)
  285.   r> +body @ task
  286. ;
  287.  
  288. : new-task ( -- task)
  289.   [compile] as                         ( Requires symbol after to be a task)
  290.   ?compile make-task                   ( type. Makes a task instance and)
  291.   ?compile dup                         ( schedules it. Return pointer to)
  292.   ?compile schedule
  293. ; immediate
  294.  
  295. : bytes ( users1 size -- users2)  
  296.   over user +                          ( Create a user variable and update)
  297. ;
  298.  
  299. : task.field ( size -- )
  300.   create ,                             ( Save size of user variable type)
  301. does> @ bytes                          ( Fetch size and create field name)
  302. ; private
  303.  
  304. : struct ( -- )
  305.   [compile] sizeof bytes               ( Fetch size of structure and create)
  306. ;
  307.  
  308. 1 task.field byte ( -- )
  309. 2 task.field word ( -- )
  310. 4 task.field long ( -- )
  311. 4 task.field ptr ( -- )
  312. 4 task.field enum ( -- )
  313.  
  314. : task.body ( task.type users3 -- ) 
  315.   align sizeof TASK-HEADER - over +users ! ( Align and assign user area size)
  316.   here swap +body !                    ( Assign pointer to task body code)
  317.   ]                                    ( And start compiling)
  318. ;
  319.  
  320. : task.end ( entry -- )
  321.   restore                              ( Remove local symbols for task type)
  322.   [compile] ;                          ( Stop compiling)
  323. ; immediate compilation
  324.  
  325. forth only
  326.